home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM BV3 / BMUG PD-ROM Version BV3 (CDRM1097900).iso / Programming / Programming Languages / Pocket Forth 6 / Examples / Window&Menu < prev   
Encoding:
Text File  |  1992-05-07  |  6.5 KB  |  157 lines  |  [TEXT/McSk]
  1. ( Window&Menu for Pocket Forth 0.6 )  page
  2. ( Be sure that you are running this demo on a COPY )
  3. ( of Pocket Forth. Close the window if you need to )
  4. ( quit and make a back up copy.                    )
  5. key drop
  6. page  0 28 +md !  ( turn off screen echo )
  7. forget task : task ; decimal
  8.  
  9. ( First define some general purpose words to create resources )
  10. ( Macros for memory manager )
  11. : >D0 ( n -- )
  12.        ,$ 4280 ,$ 301E ; macro  ( clr.l d0  move    [a6]+,d0 )
  13. : >A0 ( d -- ) ,$ 205E ; macro  (           movea.l [a6]+,a0 )
  14. : D0> ( -- n ) ,$ 3D00 ; macro  (           move    d0,-[a6] )
  15. : A0> ( -- d ) ,$ 2D08 ; macro  (           move.l  a0,-[a6] )
  16.  
  17. ( Memory management )
  18. : MERROR ( -- )  ( aborts on error in d0 )
  19.     d0> ?dup IF ." Memory Error:" . abort THEN ;
  20. : HNEW ( size -- handle )  ( create a new handle )
  21.     >d0 ,$ A122 a0> merror ;  ( _NewHandle )
  22. : HDISP ( handle -- ) >a0 ,$ A023 ;  ( _DisposHandle )
  23. : !HSIZE ( size handle -- )  ( set block size )
  24.     >a0 >d0 ,$ A024 merror ;
  25.  
  26. ( relocatable block definition )
  27. 2variable NBH 0 0 nbh 2!  ( New Block Handle holder )
  28. variable BOFFSET  0 boffset !  ( offset into the block )
  29. : ?B; ( -- flag )  ( true if "B;" is at here )
  30.     here 2@  578 = swap  15104 = and ;
  31. : BLOCK ( -- )  ( create a new 32K block )
  32.     0 boffset !  [ 32 1024 * literal ]  hnew  nbh 2! ;
  33. : :B ( -- ) ( compile numbers to the block with handle at nbh )
  34.     BEGIN
  35.       token ?b; 0= WHILE      ( while next word is not b;     )
  36.       here number IF          ( If it's a number              )
  37.         nbh 2@ dl@            (   dereference handle          )
  38.         boffset @ s>d d+  l!  (   store n at d.pointer+offset )
  39.         2 boffset +!          (   advance boffset             )
  40.       ELSE  nbh 2@ hdisp      ( not a number must be an error )
  41.         cr ." Data error at word: "  boffset @ . abort   THEN
  42.     REPEAT ;
  43. : EBLOCK ( -- dhandle )  ( finish a block creation )
  44.     boffset @ nbh 2@ !hsize  nbh 2@ ;
  45.  
  46. ( resource addition and removal )
  47. : RERROR ( -- )  ( check for resource error )
  48.     0 >r ,$ A9AF r> ?dup  ( _ResError )
  49.     IF ." Resource error: " . abort THEN ;
  50. : RGET ( id dtype -- dhandle )  ( get a resource handle )
  51.     0 0 2>r  2>r  >r  ,$ A9A0 2r> rerror ;  ( _GetResource )
  52. : RREMOVE ( dhandle -- ) 2>r ,$ A9AD ;  ( _RmveResource no err )
  53. : +RSC ( id dtype dhandle -- )  ( _AddResource to current file )
  54.     2>r 2>r >r 0 0 here 2! here a>r ,$ A9AB rerror ;
  55. : -RSC ( id dtype -- )  ( dispose of a resource )
  56.     rget 2dup rremove hdisp ;
  57.  
  58. hex  ( create the MENU resource )
  59. 4 ,s MENU -rsc ( remove any old MENU #4 )
  60. 4 ,s MENU  ( type of resource to create )
  61. block  ( put the following data into a relocatable block )
  62.     :b 0004 0000 0000 0000 0000 FFFF FFDB 0657 b;
  63.     :b 696E 646F 770B 4869 6465 2057 696E 646F b;
  64.     :b 7700 4800 0001 2D00 0000 000C 536D 616C b;
  65.     :b 6C20 5769 6E64 6F77 0000 0000 0C4C 6172 b;
  66.     :b 6765 2057 696E 646F 7700 0012 0001 2D00 b;
  67.     :b 0000 000B 5361 7665 2057 696E 646F 7700 b;
  68.     :b 4D00 0000 b;
  69. eblock +rsc  ( add a resource to Pocket Forth )
  70.  
  71. ( Now the resources are created and installed so the )
  72. ( resource creating and installing routines are not needed )
  73. decimal  forget >d0
  74.  
  75. ( Window pointer, menu handle and strings )
  76. : WINDOW ( -- window.pointer ) 0 +md 2@ ;
  77. 2variable SMENUH  ( to hold the handle to the menu )
  78. : ," ( -- ) ( compile a quoted string from input stream )
  79.     34 word here c@ 1+ dup 2 mod + allot ; IMMEDIATE
  80.  
  81. ( Show and hide the window, with toggling menu stuff. )
  82. create "HIDE" ," Hide Window"  ( string data )
  83. create "SHOW" ," Show Window"  ( string data )
  84. variable ?HIDDEN  0 ?hidden !
  85. : HIDE ( -- )
  86.     -1 ?hidden !
  87.     smenuh 2@ 2>r  1 >r  "show" a>r  ,$ A947  ( _SetItem )
  88.     window 2>r ,$ A916 ; ( _HideWindow )
  89. : SHOW ( -- )
  90.     0 ?hidden !
  91.     smenuh 2@ 2>r  1 >r  "hide" a>r  ,$ A947  ( _SetItem )
  92.     window 2>r ,$ A915 ; ( _ShowWindow )
  93. : HIDE/SHOW  ?hidden @ IF show ELSE hide THEN quit ;
  94.  
  95. ( Window size manipulation and menu checking )
  96. : WSIZE ( h v -- ) ( change the window size )
  97.     2dup  8 +md 2!  ( set the scroll rect )
  98.     window 2>r  2>r  256 >r  ,$ A91D ;  ( _SizeWindow )
  99. : WTINY ( -- )  ( make the window a two liner )
  100.      384  24 wsize  show
  101.      smenuh 2@ 2>r  3 >r  -1 >r  ,$ A945  ( _CheckItem 3 )
  102.      smenuh 2@ 2>r  4 >r  0 >r  ,$ A945 cr quit ;  ( [un]_CheckItem 4 )
  103. : WNORM ( -- )  ( bring back the normal sized window )
  104.      384 178 wsize  show
  105.      smenuh 2@ 2>r  4 >r  -1 >r  ,$ A945  ( _CheckItem 4 )
  106.      smenuh 2@ 2>r  3 >r  0 >r  ,$ A945 ;  ( [un]_CheckItem 3 )
  107.  
  108. ( Save the window's contents in a picture. )
  109. 4 +md constant WRECT  ( addr of window's rect )
  110. : WPICT ( -- dhandle ) ( the window picture's handle )
  111.     0 0 2>r  window 2>r ,$ A92F 2r> ;  ( _GetWindowPic )
  112. : KPIC ( d -- ) 2dup or IF 2>r ,$ A8F5 ELSE 2drop THEN ;
  113. : PICTURE ( rect -- dhandle ) ( open a picture leave its handle )
  114.     0 0 2>r  a>r  ,$ A8F3 2r> ;  ( _OpenPicture )
  115. : PCLOSE ( -- ) ,$ A8F4 ; macro  ( _ClosePicture )
  116. : PKILL ( addr -- ) 2@ kpic ; ( _KillPicture at addr )
  117. : WPASSIGN ( handle -- ) ( ASSIGN a Picture to Window )
  118.     window 2>r  2>r  ,$ A92E ;  ( _SetWindowPic )
  119. : BCOPY ( rect -- ) ( copy window bitmap to window )
  120.     window  2 0 d+ 2dup 2>r 2>r  ( window bits = source, destination )
  121.     dup a>r  a>r  0 >r  ( source rect, destination rect, mode )
  122.     window 24 0 d+ dl@ 2>r  ( mask to port visrgn )
  123.     ,$ A8EC ;  ( SrcCopy mode,  _CopyBits )
  124. : WSAVE ( -- ) ( save the screen for updating )
  125.     wpict kpic  ( _KillPicture )
  126.     0 0  window 148 0 d+  dl!  ( zero window picture in window record )
  127.     wrect picture  wpassign  wrect bcopy  pclose ;
  128.  
  129. ( Now create the menu arrays -- see Pocket Forth manual )
  130. create StuffMenu  ( a list of words for your menu items )
  131.     ' hide/show ,  ' null ,
  132.     ' wtiny ,  ' wnorm ,  ' null ,
  133.     ' wsave ,
  134.  
  135. create NewMenuList  ( a list of lists of your menubar )
  136.     18 +md @ @ ,     ( addr of existing File menu list )
  137.     18 +md @ 2+ @ ,  ( ditto for Edit menu list )
  138.     StuffMenu ,      ( and now Your menu )
  139.  
  140. : NUBYE  ( remove MENU resource before quitting )
  141.     smenuh 2@ 2>r  ,$ A9A3  ( _ReleaseResource )
  142.     0 0 2>r  ,s MENU 2>r 4 >r
  143.       ,$ A9A0 ,$ A9AD  ( _GetResource _RemoveResource )
  144.     bye ;  ( do the regular quit routine )
  145.     ' nubye 22 +md !  ( store this new quit routine )
  146.  
  147. : +menu ( -- ) ( Turn the new menu on.)
  148.     NewMenuList 18 +md !  ( store the new menubar list )
  149.     0 0 2>r 4 >r ,$ A9BF  ( _GetRMenu )
  150.     2r> 2dup 2>r 0 >r ,$ A935  ( _InsertMenu )
  151.     smenuh 2!  ,$ A937 ;  ( _DrawMenuBar )
  152. +menu
  153.  
  154. page  -1 28 +md !  ( turn on screen echo )
  155. ( Use the new “Windows” menu to manipulate the )
  156. ( Pocket Forth window.                         )
  157.